home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Pascal Super Library
/
Pascal Super Library (CW International)(1997).bin
/
TURB_VIS
/
RESDMP11
/
DRESFU.PAS
next >
Wrap
Pascal/Delphi Source File
|
1993-07-27
|
37KB
|
995 lines
{$A+,B-,D+,E+,F+,G-,I+,L+,N-,O-,R+,S+,V+,X+,Y-}
{ dump resource file written by RESEDIT,
W. Gross, 6-APR-92, Last change: 16-JUN-93
DumpWhat : A=all, D=TDialog, S=TStringList, M=TMenuBar, F=Focused item
ItemKEy : key of item (if DumpWhat = F)
outfile : output file
resfile : TResourceFile
StreamErrorOccured : return true, if this happens (unregistered obj.)
Handles only objects
TMenuBar, TStringList, TStatusLine and
TDialog with these controls:
TView, TButton, TRadioButton, TCheckBoxes, THistory,
TInputLine, TParamText, TListViewer, TStaticText
Program should recover from stream errors, but output is incomplete
and the heap might be unclean afterwards.
}
UNIT DResFU;
INTERFACE
USES objects;
PROCEDURE DumpIt ( DumpWhat : char;
ItemKey : String;
VAR outfile : text;
VAR ResFile : TResourceFile;
VAR StreamErrorOccured : boolean);
IMPLEMENTATION
uses dos, drivers, views, dialogs, menus, stddlg, msgbox,RESDUTIL;
TYPE TLine = ARRAY[0..80] OF char;
TScreen = Array[0..25] OF TLine;
VAR ownlabel,LinkZ : integer;
LabelLink,HistoryLink : PView;
PROCEDURE DumpIt ( DumpWhat : char;
ItemKey : String;
VAR outfile : text;
VAR ResFile : TResourceFile;
VAR StreamErrorOccured : boolean);
VAR MyObj : PObject;
FName, Key, s : String;
s15 : String[15];
TOM, TOD, TOS, TOSL : Pointer;
i, StreamStatus, StreamInfo : integer;
MB : PMenuBar;
DB : PDialog;
PMI : PMenuItem;
Screen : TScreen;
FUNCTION Hex(w:word) : String;
VAR s : String; l : longint;
BEGIN
l := longint(w);
FormatStr(s,'$%04x',l);
Hex := s;
END;
PROCEDURE PutBar ( Orig,Size :TPoint);
VAR i,j : integer;
BEGIN
FOR i := Orig.X TO Orig.X+Size.X-1 DO
FOR j := Orig.Y TO Orig.Y+Size.Y-1 DO
Screen[j,i] := '▓';
END;
PROCEDURE PutHatch ( Orig,Size :TPoint);
VAR i,j : integer;
BEGIN
FOR i := Orig.X TO Orig.X+Size.X-1 DO
FOR j := Orig.Y TO Orig.Y+Size.Y-1 DO
Screen[j,i] := '░';
END;
PROCEDURE PutShadow ( Orig,Size :TPoint);
VAR i,j : integer;
BEGIN
j := Orig.Y+Size.Y-1; Screen[j,Orig.X] := ' ';
FOR i := Orig.X+1 TO Orig.X+Size.X-1 DO Screen[j,i] := '▀';
i := Orig.X+Size.X-1; Screen[Orig.Y,i] := '▄';
FOR j := Orig.Y+1 TO Orig.Y+Size.Y-2 DO Screen[j,i] := '█';
END;
PROCEDURE PutFrame(Orig,Size : TPoint; Title : PString);
{put frame only on blank area}
VAR i,l,l2 : integer;
BEGIN
FOR i := 2 TO Size.X-1 DO
BEGIN
IF (Screen[Orig.Y,Orig.X+i-1]=' ') THEN
Screen[Orig.Y,Orig.X+i-1] := '─';
IF (Screen[Orig.Y+Size.Y-1,Orig.X+i-1]=' ') THEN
Screen[Orig.Y+Size.Y-1,Orig.X+i-1] := '─';
END;
FOR i := 2 TO Size.Y-1 DO
BEGIN
IF (Screen[Orig.Y+i-1,Orig.X]=' ') THEN
Screen[Orig.Y+i-1,Orig.X] := '│';
IF (Screen[Orig.Y+i-1,Orig.X+Size.X-1]=' ') THEN
Screen[Orig.Y+i-1,Orig.X+Size.X-1] := '│';
END;
IF (Screen[Orig.Y,Orig.X]=' ') THEN
Screen[Orig.Y,Orig.X] := '┌';
IF (Screen[Orig.Y,Orig.X+Size.X-1]=' ') THEN
Screen[Orig.Y,Orig.X+Size.X-1] := '┐';
IF (Screen[Orig.Y+Size.Y-1,Orig.X]=' ') THEN
Screen[Orig.Y+Size.Y-1,Orig.X] := '└';
IF (Screen[Orig.Y+Size.Y-1,Orig.X+Size.X-1]=' ') THEN
Screen[Orig.Y+Size.Y-1,Orig.X+Size.X-1] := '┘';
IF Title<>NIL THEN
BEGIN
l := Length(Title^); l2 := (Size.X-l) DIV 2;
FOR i := 1 TO l DO
Screen[Orig.Y, Orig.X+l2+i-1] := Title^[i];
END;
END; {PROC PutFrame}
FUNCTION TrimText ( s : String ) : String;
VAR p : integer;
BEGIN
WHILE pos ( #3, s )>0 DO
BEGIN
p := pos ( #3, s ); delete ( s, p, 1 );
insert ( '^C', s, p );
END;
WHILE pos ( #10, s )>0 DO
BEGIN
p := pos ( #10, s ); delete ( s, p, 1 );
insert ( '^J', s, p );
END;
WHILE pos ( #13, s )>0 DO
BEGIN
p := pos ( #13, s ); delete ( s, p, 1 );
insert ( '^M', s, p );
END;
TrimText := s;
END;
PROCEDURE WrapText(s:String;pos:integer);
{write string from current line position, wrap text beyond
col 80 to next line using the same indentation}
VAR sh : String; j,l,li,ld : integer;
BEGIN
s := TrimText(s);
WHILE (length(s)>0) DO
BEGIN
l := 80-pos;
IF (length(s)<=l)
THEN BEGIN li := length(s); ld := li END
ELSE
IF (s[l+1]=' ')
THEN BEGIN li := l; ld := l+1; END
ELSE
BEGIN
j := l; {search for blank}
WHILE (j>=1) AND (s[j]<>' ') DO Dec(j);
IF j=0
THEN BEGIN li := l; ld := l END {too long anyway}
ELSE BEGIN li := j-1; ld := j END; {wrap around}
END;
sh := copy (s, 1, li ); delete ( s, 1, ld );
writeln ( outfile, sh );
IF (length(s)>0) THEN write ( outfile, ' ':pos);
END;
END;{PROC WrapText}
PROCEDURE ProcessDialogB ( DB : PDialog );
VAR i,j,l,l2 : integer;
DBOrig,DBSize : TPoint;
TypeOfDesc : Pointer;
PROCEDURE InsertStaticText ( STO, STS : TPoint; s : String );
VAR i,j,j0,l,l2,li,ld, maxi, p : integer;
CRencountered, centered : boolean;
line : String;
BEGIN
i := 0; maxi := STS.Y;
REPEAT
p := pos ('~',s);
IF (p>0) THEN delete(s,p,1);
UNTIL (p=0);
l := STS.X;
CRencountered := true; {tricky initial setting}
WHILE (i<maxi) AND (s<>'') DO
BEGIN
Inc(i);
IF CRencountered THEN {last char processed was CR}
BEGIN
centered := (s[1] = #3);
IF centered THEN delete (s,1,1);
END;
CRencountered := false;
{^M hier erledigen}
p := pos ( #13, s );
IF (p>0) AND ((p-1)<=l)
THEN {text up to next ^M fits into line}
BEGIN
line := copy ( s, 1, p-1 ); delete ( s, 1, p );
CRencountered := true;
END
ELSE
IF length(s)<=l
THEN BEGIN line := s; s := ''; END
ELSE
BEGIN
IF (s[l+1]=' ') OR (i=maxi) {doesn't fit anyway}
THEN BEGIN li := l; ld := l+1; END
ELSE
BEGIN
j := l; {search for blank}
WHILE (j>=1) AND (s[j]<>' ') DO Dec(j);
IF j=0
THEN BEGIN li := l; ld := l END {too long anyway}
ELSE BEGIN li := j-1; ld := j END; {wrap around}
END;
line := copy (s, 1, li ); delete ( s, 1, ld );
END;
IF NOT CREncountered THEN {wrap around in progress}
WHILE (s<>'') AND (s[1]=' ') DO delete ( s, 1, 1);
j0 := 1;
IF centered THEN
BEGIN
WHILE (length(line)>=1) AND (line[length(line)]=' ') DO
delete(line, length(line),1);
l2 := length(line); j := (l-l2) DIV 2; j0 := j+1;
WHILE (j>=1) DO BEGIN line := ' '+line; dec(j); END;
END;
FOR j := j0 TO length(line) DO
Screen[DBOrig.Y+STO.Y+i-1, DBOrig.X+STO.X+j-1] := line[j];
END; {WHILE (i<maxi) AND ... }
END; {InsertStaticText}
PROCEDURE WriteButton ( P : PView ) ; far;
VAR i : integer; sh : String; VO,VOS : TPoint;
BEGIN
ownlabel := ownlabel+1;
IF TypeOf(P^)=TypeOf(TButton) THEN
WITH PButton(P)^ DO
BEGIN
writeln ( outfile, ownlabel:3, ': ',
'(', Origin.X:2, ',', Origin.Y:2, ') (',
Size.X:2, ',', Size.Y:2, ') ',
Command:5, ' ', HelpCtx:5, ' ', hex(flags):5, ' ',
hex(options):6, ' [', Title^, ']' );
VO.X := DBOrig.X+Origin.X+1; VO.Y := DBOrig.Y+Origin.Y;
VOS.X := Size.X-1; VOS.Y := Size.Y;
PutHatch ( VO, VOS );
PutShadow ( VO, VOS );
sh := Title^;
IF (flags AND bfLeftJust)=0 THEN sh := #3+sh;
VO.X := Origin.X+1;
VO.Y := Origin.Y+(VOS.Y DIV 2)-1; VOS.Y := 2;
InsertStaticText ( VO, VOS, sh );
END;
END;
PROCEDURE WriteCluster ( P : PView ) ; far;
{called by WriteRadioButtons or WriteCheckBoxes,
nonlocal: ownlabel}
VAR i,l,linkz,NoOfLines,NextItem,NoOfItemsPerColumn : integer;
sh : String;
NewOrig,LO,SI : TPoint;
DV : PView;
IsRButton : boolean;
PS : PString;
FUNCTION TestLabel(View : PView) : boolean;far;
{use this in a FirstThat call to obtain the label which is
linked to this view, side effect for LinkZ !!!}
BEGIN
Inc(LinkZ);
if (TypeOf(View^) = TypeOf(TLabel)) and
(PLabel(View)^.Link = P) then
begin TestLabel := True; Exit; end;
TestLabel := False;
END;
FUNCTION Min ( a,b : integer ) : integer;
BEGIN
IF a<b THEN Min := a ELSE Min := b;
END;
BEGIN
linkz := 0;
WITH PCluster(P)^ DO
BEGIN
IsRButton := TypeOf(P^)=TypeOf(TRadioButtons);
write ( outfile, ownlabel:3, ': ',
'(', Origin.X:2, ',', Origin.Y:2, ') (',
Size.X:2, ',', Size.Y:2, ') ',
HelpCtx:5, ' ', hex(options):6, ' ' );
IF IsRButton THEN write ( outfile, value:5, ' ' )
ELSE write ( outfile, hex(value):6, ' ' );
DV := DB^.FirstThat(@TestLabel);{side effect for LinkZ}
IF DV<>NIL THEN write ( outfile, LinkZ:4, ' ' )
ELSE write ( outfile, ' ');
sh := '';
IF (Options AND ofFramed)=ofFramed THEN
BEGIN
LO.X := DBOrig.X+Origin.X-1;
LO.Y := DBOrig.Y+Origin.Y-1;
SI.X := Size.X+2; SI.Y := Size.Y+2;
PutFrame ( LO, SI, nil);
END;
WITH Strings DO
BEGIN
NoOfLines := Size.Y; NewOrig := Origin;
NextItem := 0;
REPEAT
NoOfItemsPerColumn := Min ( NoOfLines, count-NextItem);
l := 0; sh := '';
FOR i := NextItem TO NextItem+NoOfItemsPerColumn-1 DO
BEGIN
PS := PString(Items^[i]);
writeln ( outfile, PS^ );
IF length(PS^) > l THEN l := Length(PS^);
IF IsRButton
THEN
BEGIN
IF value=i THEN sh := sh + ' (∙) '
ELSE sh := sh + ' ( ) ';
END
ELSE
BEGIN
IF ((value shr i) AND 1)=1
THEN sh := sh+' [x] ' ELSE sh := sh+ ' [ ] ';
END;
sh := sh+PString(Items^[i])^;
IF i<count-1 THEN
BEGIN
write ( outfile, ' ':47 ); sh := sh+#13;
END;
END; {FOR i := NextItem ... }
InsertStaticText ( NewOrig, Size, sh );
NewOrig.X := NewOrig.X+l+6;
NextItem := NextItem+NoOfItemsPerColumn;
UNTIL (NextItem > (count-1));
END; {WITH Strings DO ...}
END; {WITH PCluster(P)^ DO ...}
END;
PROCEDURE WriteRadioButtons ( P : PView ) ; far;
BEGIN
ownlabel := ownlabel+1;
IF (TypeOf(P^)=TypeOf(TRadioButtons)) THEN WriteCluster(P);
END;
PROCEDURE WriteCheckBoxes ( P : PView ) ; far;
BEGIN
ownlabel := ownlabel+1;
IF (TypeOf(P^)=TypeOf(TCheckBoxes)) THEN WriteCluster(P);
END;
PROCEDURE WriteStaticText ( P : PView ) ; far;
VAR i : integer; sh : String; LO, SI : TPoint;
BEGIN
ownlabel := ownlabel+1;
IF TypeOf(P^)=TypeOf(TStaticText) THEN
WITH PStaticText(P)^ DO
BEGIN
sh := TrimText(Text^);
write ( outfile, ownlabel:3, ': ',
'(', Origin.X:2, ',', Origin.Y:2, ') (',
Size.X:2, ',', Size.Y:2, ') ', hex(options):6, ' ');
IF (Options AND ofFramed)=ofFramed THEN
BEGIN
LO.X := DBOrig.X+Origin.X-1;
LO.Y := DBOrig.Y+Origin.Y-1;
SI.X := Size.X+2; SI.Y := Size.Y+2;
PutFrame ( LO, SI, nil);
END;
WrapText(sh,29);
InsertStaticText ( Origin, Size, Text^ );
END;
END;
PROCEDURE WriteParamText ( P : PView ) ; far;
VAR i : integer; sh : String; LO, SI : TPoint;
BEGIN
ownlabel := ownlabel+1;
IF TypeOf(P^)=TypeOf(TParamText) THEN
WITH PParamText(P)^ DO
BEGIN
sh := TrimText(Text^);
write ( outfile, ownlabel:3, ': ',
'(', Origin.X:2, ',', Origin.Y:2, ') (',
Size.X:2, ',', Size.Y:2, ') ', hex(options):6,
' ', ParamCount:2, ' ');
IF (Options AND ofFramed)=ofFramed THEN
BEGIN
LO.X := DBOrig.X+Origin.X-1;
LO.Y := DBOrig.Y+Origin.Y-1;
SI.X := Size.X+2; SI.Y := Size.Y+2;
PutFrame ( LO, SI, nil);
END;
WrapText(sh,35);
InsertStaticText ( Origin, Size, Text^ );
END;
END;
PROCEDURE WriteLabel ( P : PView ) ; far;
VAR i : integer; sh : String; DV : PView;
FUNCTION TestLink(View : PView) : boolean;far;
{use this in a FirstThat call to obtain the view the label
is linked to}
BEGIN
Inc(LinkZ); TestLink := (View=LabelLink);
END;
BEGIN
ownlabel := ownlabel+1;
IF TypeOf(P^)=TypeOf(TLabel) THEN
WITH PLabel(P)^ DO
BEGIN
sh := TrimText(Text^);
LinkZ := 0; LabelLink := PLabel(P)^.Link;
DV := DB^.FirstThat(@TestLink);{side effect for LinkZ}
IF DV=nil THEN LinkZ:=0;
writeln ( outfile, ownlabel:3, ': ',
'(', Origin.X:2, ',', Origin.Y:2, ') (',
Size.X:2, ',', Size.Y:2, ') ',
hex(options):6, ' ', LinkZ:3, ' ', sh );
{labels have leading blank, don't ask me why}
InsertStaticText ( Origin, Size, ' '+Text^ );
END;
END;
PROCEDURE WriteHistory ( P : PView ) ; far;
VAR i : integer; sh : String; DV : PView;
FUNCTION TestLink(View : PView) : boolean;far;
{use this in a FirstThat call to obtain the view the label
is linked to}
BEGIN
Inc(LinkZ); TestLink := (View=HistoryLink);
END;
BEGIN
ownlabel := ownlabel+1;
IF TypeOf(P^)=TypeOf(THistory) THEN
WITH PHistory(P)^ DO
BEGIN
LinkZ := 0; HistoryLink := PHistory(P)^.Link;
DV := DB^.FirstThat(@TestLink);{side effect for LinkZ}
IF DV=nil THEN LinkZ:=0;
writeln ( outfile, ownlabel:3, ': ',
'(', Origin.X:2, ',', Origin.Y:2, ') (',
Size.X:2, ',', Size.Y:2, ') ',
hex(options):6, ' ', HistoryID:4, ' ', LinkZ:4 );
InsertStaticText ( Origin, Size, ' |' );
END;
END;
PROCEDURE WriteInputLine ( P : PView ) ; far;
VAR i,LinkZ : integer; DV : PView; LO,SI : TPoint;
FUNCTION TestLabel(View : PView) : boolean;far;
{use this in a FirstThat call to obtain the label which is
linked to this view, side effect for LinkZ !!!}
BEGIN
Inc(LinkZ);
if (TypeOf(View^) = TypeOf(TLabel)) and
(PLabel(View)^.Link = P) then
begin TestLabel := True; Exit; end;
TestLabel := False;
END;
FUNCTION TestHistory(View : PView) : boolean;far;
{use this in a FirstThat call to obtain the history object which is
linked to this view, side effect for LinkZ !!!}
BEGIN
Inc(LinkZ);
if (TypeOf(View^) = TypeOf(THistory)) and
(PHistory(View)^.Link = PInputLine(p)) then
begin TestHistory := True; Exit; end;
TestHistory := False;
END;
BEGIN
ownlabel := ownlabel+1;
IF TypeOf(P^)=TypeOf(TInputLine) THEN
WITH PInputLine(P)^ DO
BEGIN
write ( outfile, ownlabel:3, ': ',
'(', Origin.X:2, ',', Origin.Y:2, ') (',
Size.X:2, ',', Size.Y:2, ') ',
HelpCtx:5, ' ', hex(options):6, ' ', MaxLen:6, ' ');
IF (Options AND ofFramed)=ofFramed THEN
BEGIN
LO.X := DBOrig.X+Origin.X-1;
LO.Y := DBOrig.Y+Origin.Y-1;
SI.X := Size.X+2; SI.Y := Size.Y+2;
PutFrame ( LO, SI, nil);
END;
LinkZ := 0;
DV := DB^.FirstThat(@TestLabel);{side effect for LinkZ}
IF DV<>NIL THEN write ( outfile, LinkZ:4, ' ' )
ELSE write ( outfile, ' ' );
LinkZ := 0;
DV := DB^.FirstThat(@TestHistory);{side effect for LinkZ}
IF DV<>NIL THEN writeln ( outfile, LinkZ:4 )
ELSE writeln ( outfile );
FOR i := 1 TO Size.X DO
Screen[DBOrig.Y+Origin.Y,DBOrig.X+Origin.X+i-1] := '_';
END;
END;
PROCEDURE WriteListViewer ( P : PView) ; far;
{for TListViewer and its descendants TListBox, TSortedListBox,
nonlocal TypeOfDesc}
VAR i,LinkZ : integer;
sb : String;
LO,BO,SI :TPoint;
DV : PView;
FUNCTION TestLabel(View : PView) : boolean;far;
{use this in a FirstThat call to obtain the label which is
linked to this view, side effect for LinkZ !!!}
BEGIN
Inc(LinkZ);
if (TypeOf(View^) = TypeOf(TLabel)) and
(PLabel(View)^.Link = P) then
begin TestLabel := True; Exit; end;
TestLabel := False;
END;
BEGIN
ownlabel := ownlabel+1; LinkZ := 0;
IF TypeOf(P^)=TypeOfDesc THEN
WITH PListViewer(P)^ DO
BEGIN
sb := ''; IF HScrollBar<>NIL THEN sb := 'H';
IF VScrollBar<>NIL THEN sb := sb+'V';
write ( outfile, ownlabel:3, ': ',
'(', Origin.X:2, ',', Origin.Y:2, ') (',
Size.X:2, ',', Size.Y:2, ') ',
HelpCtx:5, ' ', hex(options):6, ' ', sb:6, ' ' );
DV := DB^.FirstThat(@TestLabel);{side effect for LinkZ}
IF DV<>NIL THEN writeln ( outfile, LinkZ:4 )
ELSE writeln ( outfile );
IF (Options AND ofFramed)=ofFramed THEN
BEGIN
LO.X := DBOrig.X+Origin.X-1;
LO.Y := DBOrig.Y+Origin.Y-1;
SI.X := Size.X+2; SI.Y := Size.Y+2;
PutFrame ( LO, SI, nil);
END;
LO.X := DBOrig.X+Origin.X;
LO.Y := DBOrig.Y+Origin.Y;
PutFrame ( LO, Size, nil);
IF VScrollBar<>NIL THEN
BEGIN
BO.X := DBOrig.X+VScrollBar^.Origin.X;
BO.Y := DBOrig.Y+VScrollBar^.Origin.Y;
PutBar(BO,VScrollBar^.Size);
END;
IF HScrollBar<>NIL THEN
BEGIN
BO.X := DBOrig.X+HScrollBar^.Origin.X;
BO.Y := DBOrig.Y+HScrollBar^.Origin.Y;
PutBar(BO,HScrollBar^.Size);
END;
END;
END;
PROCEDURE WriteView ( P : PView ) ; far;
VAR i : integer; sh : String; VO : TPoint;
BEGIN
ownlabel := ownlabel+1;
IF TypeOf(P^)=TypeOf(TView) THEN
WITH PView(P)^ DO
BEGIN
writeln ( outfile, ownlabel:3, ': ',
'(', Origin.X:2, ',', Origin.Y:2, ') (',
Size.X:2, ',', Size.Y:2, ') ', hex(options):6, ' ');
VO.X := DBOrig.X+Origin.X; VO.Y := DBOrig.Y+Origin.Y;
PutHatch ( VO, Size );
END;
END;
{-------------------------------------}
FUNCTION CheckLabel ( P:PView) : boolean; far;
BEGIN
CheckLabel := TypeOF(P^) = TypeOf(TLabel);
END;
FUNCTION CheckButton ( P:PView) : boolean; far;
BEGIN
CheckButton := TypeOF(P^) = TypeOf(TButton);
END;
FUNCTION CheckRadioButtons ( P:PView) : boolean; far;
BEGIN
CheckRadioButtons := TypeOF(P^) = TypeOf(TRadioButtons);
END;
FUNCTION CheckCheckBoxes ( P:PView) : boolean; far;
BEGIN
CheckCheckBoxes := TypeOF(P^) = TypeOf(TCheckBoxes);
END;
FUNCTION CheckStaticText ( P:PView) : boolean; far;
BEGIN
CheckStaticText := TypeOF(P^) = TypeOf(TStaticText);
END;
FUNCTION CheckParamText ( P:PView) : boolean; far;
BEGIN
CheckParamText := TypeOF(P^) = TypeOf(TParamText);
END;
FUNCTION CheckInputLine ( P:PView) : boolean; far;
BEGIN
CheckInputLine := TypeOF(P^) = TypeOf(TInputLine);
END;
FUNCTION CheckListViewer ( P:PView) : boolean; far;
BEGIN
CheckListViewer := TypeOF(P^) = TypeOf(TListViewer);
END;
FUNCTION CheckListBox ( P:PView) : boolean; far;
BEGIN
CheckListBox := TypeOF(P^) = TypeOf(TListBox);
END;
FUNCTION CheckSortedListBox ( P:PView) : boolean; far;
BEGIN
CheckSortedListBox := TypeOF(P^) = TypeOf(TSortedListBox);
END;
FUNCTION CheckHistory ( P:PView) : boolean; far;
BEGIN
CheckHistory := TypeOF(P^) = TypeOf(THistory);
END;
FUNCTION CheckView ( P:PView) : boolean; far;
BEGIN
CheckView := TypeOF(P^) = TypeOf(TView);
END;
BEGIN {main processdialogb}
WITH DB^ DO
BEGIN
DBOrig := Origin; DBSize := Size;
IF Title<>NIL THEN writeln ( outfile, ' ', Title^, ' ' );
writeln ( outfile, ' Orig:(', Origin.X:2, ',', Origin.Y:2,
'), Size:(', Size.X:2, ',', Size.Y:2, ')',
', hcxxxx:', HelpCtx:5,
', Options:', Hex(Options):5,
', Flags:', hex(flags):5 );
END;
FOR i := 0 TO 80 DO Screen[0,i] := ' ' ;
FOR i := 1 TO 25 DO Screen[i] := Screen[0];
writeln ( outfile );
PutFrame(DBOrig,DBSize, DB^.Title);
IF DB^.FirstThat(@CheckButton)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TButton]'); writeln ( outfile );
writeln ( outfile,
' Z: Origin Size cmxxx hcxxx Flags Options Title' );
DB^.ForEach(@WriteButton);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
IF DB^.FirstThat(@CheckInputLine)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TInputLine]'); writeln ( outfile );
writeln ( outfile,
' Z: Origin Size hcxxx Options AMaxLen Label History' );
DB^.ForEach(@WriteInputLine);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
IF DB^.FirstThat(@CheckListViewer)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TListViewer]'); writeln ( outfile );
writeln ( outfile,
' Z: Origin Size hcxxx Options ScrollB Label' );
TypeOfDesc := TypeOf(TListViewer);
DB^.ForEach(@WriteListViewer);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
IF DB^.FirstThat(@CheckListBox)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TListBox]'); writeln ( outfile );
writeln ( outfile,
' Z: Origin Size hcxxx Options ScrollB Label' );
TypeOfDesc := TypeOf(TListBox);
DB^.ForEach(@WriteListViewer);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
IF DB^.FirstThat(@CheckSortedListBox)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TSortedListBox]'); writeln ( outfile );
writeln ( outfile,
' Z: Origin Size hcxxx Options ScrollB Label' );
TypeOfDesc := TypeOf(TSortedListBox);
DB^.ForEach(@WriteListViewer);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
IF DB^.FirstThat(@CheckRadioButtons)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TRadioButtons]'); writeln ( outfile );
writeln ( outfile,
' Z: Origin Size hcxxx Options Value Label Items' );
DB^.ForEach(@WriteRadioButtons);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
IF DB^.FirstThat(@CheckCheckBoxes)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TCheckBoxes]'); writeln ( outfile );
writeln ( outfile,
' Z: Origin Size hcxxx Options Value Label Items' );
DB^.ForEach(@WriteCheckBoxes);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
IF DB^.FirstThat(@CheckHistory)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [THistory]'); writeln ( outfile );
writeln ( outfile, ' Z: Origin Size Options HistID Link' );
DB^.ForEach(@WriteHistory);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
IF DB^.FirstThat(@CheckView)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TView]'); writeln ( outfile );
writeln ( outfile, ' Z: Origin Size Options' );
DB^.ForEach(@WriteView);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
{must be last to write over frames}
IF DB^.FirstThat(@CheckStaticText)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TStaticText]'); writeln ( outfile );
writeln ( outfile, ' Z: Origin Size Options Text' );
DB^.ForEach(@WriteStaticText);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
IF DB^.FirstThat(@CheckParamText)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TParamText]'); writeln ( outfile );
writeln ( outfile, ' Z: Origin Size Options Count Text' );
DB^.ForEach(@WriteParamText);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
IF DB^.FirstThat(@CheckLabel)<>NIL THEN
BEGIN
ownlabel := 0;
writeln ( outfile, ' [TLabel]'); writeln ( outfile );
writeln ( outfile, ' Z: Origin Size Options Link Text' );
DB^.ForEach(@WriteLabel);
writeln ( outfile, ' ---------------------'); writeln ( outfile );
END;
writeln ( outfile );
FOR i := DBOrig.Y TO DBOrig.Y+DBSize.Y DO
BEGIN
FOR j := 0 TO 80 DO
write ( outfile, Screen[i,j]) ;
writeln ( outfile );
END;
writeln ( outfile );
END; {PROC ProcessDialogB}
PROCEDURE DoIt(Key:String;MyObj:PObject;
StreamStatus,StreamInfo:integer);
{nonlocal MyObj}
VAR w,max : word;
err : integer;
SL : PStringList;
s35 : String[35];
s15 : String[15];
Typ : String;
STDef : PStatusDef; STItem : PStatusItem;
PROCEDURE PrintPMI( PMI:PMenuItem; level : integer );
VAR s40 : String[40];
s15 : String[15];
i : integer;
cmd, hcxxxx : word;
BEGIN
WHILE PMI<>NIL DO
BEGIN
WITH PMI^ DO
BEGIN
s40 := '';
FOR i := 1 TO (2*level) DO s40 := s40 + ' ';
IF Name<>NIL
THEN
BEGIN
s40 := s40 + Name^;
cmd := command; hcxxxx := HelpCtx
END
ELSE
BEGIN {command and HelpCtx are undefined !}
s40 := s40 + '──────────────────';
cmd := 0; hcxxxx := 0
END;
s40 := s40 + ' ';
IF KeyCode<>0 THEN s15 := KeyName(KeyCode) ELSE s15 := '';
s15 := s15 + ' ';
writeln ( outfile, s40, ' ', s15, ' ',
cmd:5, ' ', hcxxxx:5 );
IF (command=0) AND (name<>nil) AND (SubMenu<>nil) THEN
PrintPMI(SubMenu^.Items,level+1);
END; {WITH PMI^ ... }
PMI := PMI^.NEXT;
END;
END; {PROC PrintPMI}
BEGIN
Typ := '';
IF TypeOf(MyObj^)=TOM THEN Typ := '[TMenubar]';
IF TypeOf(MyObj^)=TOD THEN Typ := '[TDialog]';
IF TypeOf(MyObj^)=TOS THEN Typ := '[TStringList]';
IF TypeOf(MyObj^)=TOSL THEN Typ := '[TStatusline]';
s35 := Key+' ';
IF Typ='' THEN
BEGIN
writeln ( outfile, 'Cannot handle object "', key, '".' );
writeln ( outfile, 'Subviews must be part of a TDialog object.');
writeln ( outfile );
END;
IF StreamStatus<>stok THEN
BEGIN
writeln ( outfile,
'Warning: Stream error occured while reading object "', Key, '".' );
write ( outfile, 'Status code: ', StreamStatus:4, ', ' );
IF StreamStatus=stGetError
THEN writeln ( outfile, 'unregistered ObjType: ', StreamInfo:4)
ELSE writeln ( outfile, 'DOS/EMS error code: ', StreamInfo:4 );
writeln ( outfile );
END;
IF (Typ='[TStringList]') AND (DumpWhat IN ['A','S','F']) THEN
BEGIN
writeln ( outfile, s35, Typ ); writeln ( outfile );
SL := PStringList(Resfile.Get(Key));
{RESEDIT stores highest key used at position 65535}
Val (SL^.Get(65535),max,err);
IF err<>0 THEN max := 65535;
FOR w := 0 TO max DO
BEGIN
s := SL^.Get(w);
IF s<>'' THEN
BEGIN
write ( outfile, w:5, ' ');
WrapText( s, 7 );
END;
END;
Dispose(SL, Done );
END;
IF (Typ='[TDialog]') AND (DumpWhat IN ['A','D','F']) THEN
BEGIN
writeln ( outfile, s35, Typ ); writeln ( outfile );
DB := PDialog(MyObj);
ProcessDialogB (DB);
END;
IF (Typ='[TStatusline]') AND (DumpWhat IN ['A','L','F']) THEN
BEGIN
writeln ( outfile, s35, Typ ); writeln ( outfile );
writeln ( outfile,
'hc range Command Key Text');
writeln ( outfile );
STDef := PStatusLine(MyObj)^.Defs;
WHILE STDef<>NIL DO
BEGIN
write ( outfile, hex(STDef^.Min):5, '-', hex(STDef^.Max):5,
' : ' );
STItem := STDef^.Items;
WHILE STItem<>NIL DO
BEGIN
WITH STItem^ DO
BEGIN
s15 := '';
IF keycode<>0 THEN s15 := Keyname(KeyCode);
s15 := s15 + ' ';
write ( outfile, command:5, ' ', s15, ' ' );
IF Text<>NIL THEN write ( outfile, Text^ );
writeln (outfile);
END;
STItem := STItem^.next;
IF STItem<>NIL THEN write ( outfile, ' ':16);
END;
STDef := STDef^.Next;
END; {WHILE STDef<>NIL ...}
END;
IF (Typ='[TMenubar]') AND (DumpWhat IN ['A','M','F']) THEN
BEGIN
writeln ( outfile, s35, Typ ); writeln ( outfile );
MB := PMenuBar(MyObj);
PMI := MB^.Menu^.Items;
writeln ( outfile,
'Menuitem KeyCode cmxxxx hcxxxx');
writeln ( outfile );
PrintPMI(PMI,0);
END;
writeln ( outfile );
writeln ( outfile,
'----------------------------------------------------');
IF MyObj<>NIL THEN Dispose(MyObj,Done);
END; {PROC DoIt}
PROCEDURE CheckStreamStatus ( VAR streamstatus, streaminfo : integer;
VAR StreamErrorOccured : boolean );
{check stream status, reset stream in case of error,
mark error in var StreamErrorOccured}
VAR stat : integer;
BEGIN
streaminfo := 0;
streamstatus := ResFile.Stream^.status;
IF (streamstatus<>stOk) THEN {unregistered object}
BEGIN
StreamErrorOccured := true;
streaminfo := ResFile.Stream^.ErrorInfo;
ResFile.Stream^.Reset; {resume stream operation}
END;
END; {CheckStreamStatus}
BEGIN {main}
TOM := TypeOf(TMenuBar);
TOD := TypeOf(TDialog);
TOS := TypeOf(TStringList);
TOSL:= TypeOf(TStatusLine);
StreamErrorOccured := false;
IF DumpWhat='F' {focused item}
THEN
BEGIN
MyObj := ResFile.Get(ItemKey);
Key := ItemKey;
CheckStreamStatus(streamstatus,streaminfo,StreamErrorOccured);
DoIt(Key,MyObj,streamstatus,streaminfo);
END
ELSE
FOR i := 0 TO ResFile.Count-1 DO
BEGIN
Key := ResFile.KeyAt(i);
MyObj := ResFile.Get(Key); {delete later, }
CheckStreamStatus(streamstatus,streaminfo,StreamErrorOccured);
DoIt(Key,MyObj,streamstatus,streaminfo);
END; {FOR i := 0 TO ... }
END; {PROC DumpIt}
END. {UNIT DResFU}